unit SAXKW;

{
  Simple API for XML 2.0 (SAX) Implementation.
  IXMLReader implementation by native Delphi parser.
  Based on standard at http://www.saxproject.org/.

  Copyright ?Keith Wood (kbwood@compuserve.com)
  Written 11 June, 2000.
  Updated 4 July, 2003.
}

interface

{$I SAX.inc}

uses
  Classes, SysUtils,
{$IFDEF DELPHI6_UP}
  Variants,
{$ENDIF}
  SAX, SAXExt, SAXHelpers, ParserXML;

const

  SAX_VENDOR_KEITHWOOD = SAXString('Keith Wood');

type

  IKWDeclHandlerProperty = interface(IInterfaceProperty)
    ['{81554D2A-C44C-4207-B2B6-647D24C25CC1}']
  end;

  IKWLexicalHandlerProperty = interface(IInterfaceProperty)
    ['{6C5576EC-649F-4426-A5CE-2009F18DA613}']
  end;


  { SAX2 compliant XML reader using above parser }
  TSAXDelphiReader = class(TXMLReaderImpl,
    IKWDeclHandlerProperty, IKWLexicalHandlerProperty)
  private
    FDeclarations: TStringList;
    FDeclHandler: IDeclHandler;
    FElements: TStringList;
    FEntities: TStringList;
    FLexicalHandler: ILexicalHandler;
    FNSSupport: TNamespaceSupport;
    FParser: TXMLParser;
    procedure DoAttrDecl(Name: SAXString; Attribs: TStringList);
    procedure DoCData(Text: SAXString);
    procedure DoComment(Comment: SAXString);
    procedure DoDTD(Name: SAXString; TagType: TXMLTagType;
      Attribs: TStringList);
    procedure DoElement(Tag: SAXString; TagType: TXMLTagType;
      Attribs: TStringList);
    procedure DoElementDecl(Name, Model: SAXString);
    procedure DoEndDocument;
    procedure DoEntity(Name: SAXString; Attribs: TStringList);
    procedure DoEntityRef(Name: SAXString);
    procedure DoInstruction(Target, Data: SAXString);
    procedure DoNotation(Name: SAXString; Attribs: TStringList);
    procedure DoStartDocument;
    procedure DoText(Text: SAXString);
    function DoQueryInterfaceDeclHandler(const IID: TGUID;
      out Obj): HResult; stdcall;
    function DoGetDeclHandlerPropertyName : SAXString;
    function DoGetDeclHandlerPropertyValue : IUnknown;
    procedure DoSetDeclHandlerPropertyValue(const value : IUnknown);
    function DoQueryInterfaceLexicalHandler(const IID: TGUID;
      out Obj): HResult; stdcall;
    function DoGetLexicalHandlerPropertyName : SAXString;
    function DoGetLexicalHandlerPropertyValue : IUnknown;
    procedure DoSetLexicalHandlerPropertyValue(const value : IUnknown);
    procedure Error(Message: string);
  protected
    function IKWDeclHandlerProperty.QueryInterface = DoQueryInterfaceDeclHandler;
    function IKWDeclHandlerProperty.getName = DoGetDeclHandlerPropertyName;
    function IKWDeclHandlerProperty.getValue = DoGetDeclHandlerPropertyValue;
    procedure IKWDeclHandlerProperty.setValue = DoSetDeclHandlerPropertyValue;
    function IKWLexicalHandlerProperty.QueryInterface = DoQueryInterfaceLexicalHandler;
    function IKWLexicalHandlerProperty.getName = DoGetLexicalHandlerPropertyName;
    function IKWLexicalHandlerProperty.getValue = DoGetLexicalHandlerPropertyValue;
    procedure IKWLexicalHandlerProperty.setValue = DoSetLexicalHandlerPropertyValue;
  public
    constructor Create; reintroduce; overload;
    constructor Create(ContentHandler: IContentHandler;
      DTDHandler: IDTDHandler = nil; EntityResolver: IEntityResolver = nil;
      ErrorHandler: IErrorHandler = nil); reintroduce; overload; 
    destructor Destroy; override;
    function GetColumnNumber: Integer; override;
    function GetLineNumber: Integer; override;
    function GetProperty(const Name: SAXString): IProperty; override;
    procedure ParseInput(const Input: IInputSource); override;
    function ResolveEntityRef(const Name: SAXString): SAXString;
  end;

  TSAXDelphiVendor = class(TSAXVendor)
    function Description: string; override;
    function XMLReader: IXMLReader; override;
  end;
  
  TSAXDelphi = class(TComponent)
  private
    function GetVendor: string;
  published
    property Vendor: string read GetVendor;
  end;

implementation

resourcestring
  { Error messages }
  Absent            = 'absent';
  AttrDeclaration   = 'Error in declaration for attribute s';
  InvalidEntityRef  = 'Invalid entity reference found - %s';
  MismatchedClosing = 'Mismatched closing tag - %s - should be %s';
  MissingClosing    = 'Missing closing tag(s) - %s';
  PropertyName      = 'Property: %s';

const
  XMLDecl   = 'xml';
  XMLNSAttr = 'xmlns';

{ TSAXDelphiReader -----------------------------------------------------------}

{ Initialisation }
constructor TSAXDelphiReader.Create;
begin
  inherited Create;
  FDeclarations        := TStringList.Create;
  FDeclarations.Sorted := True;
  FDeclHandler         := nil;
  FElements            := TStringList.Create;
  FEntities            := TStringList.Create;
  FEntities.Duplicates := dupIgnore;  { Keep first one only }
  FLexicalHandler      := nil;
  FNSSupport           := TNamespaceSupport.Create;
  FParser              := nil;
end;

{ Initialisation using specified XML handlers }
constructor TSAXDelphiReader.Create(ContentHandler: IContentHandler;
  DTDHandler: IDTDHandler = nil; EntityResolver: IEntityResolver = nil;
  ErrorHandler: IErrorHandler = nil);
begin
  Create;
  Self.setContentHandler(ContentHandler);
  Self.setDTDHandler(DTDHandler);
  Self.setEntityResolver(EntityResolver);
  Self.setErrorHandler(ErrorHandler);
end;

{ Release resources }
destructor TSAXDelphiReader.Destroy;
begin
  FDeclarations.Free;
  FElements.Free;
  FEntities.Free;
  FNSSupport.Free;
  FDeclHandler    := nil;
  FLexicalHandler := nil;
  inherited Destroy;
end;

{ Declare an attribute }
procedure TSAXDelphiReader.DoAttrDecl(Name: SAXString; Attribs: TStringList);
var
  Index: Integer;
  AttrName, AttrType, Value, ValueDefault: SAXString;
begin
  if Assigned(FDeclHandler) then
    try
      Index := 0;
      while Index < Attribs.Count do
      begin
        AttrName := Attribs[Index];
        Inc(Index);
        { Extract attribute type }
        AttrType := Attribs[Index];
        Inc(Index);
        if (AttrType[1] = '(') or (AttrType = 'NOTATION') then
        begin
          { Enumerated type - compile to the end of the list }
          if AttrType = 'NOTATION' then
            AttrType := AttrType + ' ';
          while (Index < Attribs.Count - 1) and (AttrType[Length(AttrType)] <> ')') do
          begin
            AttrType := AttrType + Attribs[Index];
            Inc(Index);
          end;
        end;
        { Extract default status and value }
        ValueDefault := '';
        Value        := '';
        if (Index < Attribs.Count) and ((Attribs[Index] = '#REQUIRED') or
            (Attribs[Index] = '#IMPLIED') or (Attribs[Index] = '#FIXED')) then
        begin
          ValueDefault := Attribs[Index];
          Inc(Index);
        end;
        if (Index < Attribs.Count) and
            ((ValueDefault = '') or (ValueDefault = '#FIXED')) then
        begin
          Value := Attribs[Index];
          Inc(Index);
        end;
        if FDeclarations.IndexOf(Name + '~' + AttrName) = -1 then
        begin
          { Report first declaration only }
          FDeclarations.Add(Name + '~' + AttrName);
          FDeclHandler.AttributeDecl(Name, AttrName,
            AttrType, ValueDefault, Value);
        end;
      end;
    except on Exc: Exception do
      raise ESAXParseException.Create(
        Format(AttrDeclaration, [Name + '.' + AttrName]),
        getPublicId, getSystemId, getLineNumber, getColumnNumber);
    end;
end;

{ Process a CDATA section }
procedure TSAXDelphiReader.DoCData(Text: SAXString);
begin
  if Assigned(FLexicalHandler) then
    FLexicalHandler.StartCData;
  getContentHandler.Characters(Text);
  if Assigned(FLexicalHandler) then
    FLexicalHandler.EndCData;
end;

{ Process a comment }
procedure TSAXDelphiReader.DoComment(Comment: SAXString);
begin
  if Assigned(FLexicalHandler) then
    FLexicalHandler.Comment(Comment);
end;

{ Process a DTD reference }
procedure TSAXDelphiReader.DoDTD(Name: SAXString; TagType: TXMLTagType;
  Attribs: TStringList);
begin
  if Assigned(FLexicalHandler) then
  begin
    if TagType = ttOpening then
      FLexicalHandler.StartDTD(Name, Attribs.Values[PublicAttr],
        Attribs.Values[SystemAttr])
    else
      FLexicalHandler.EndDTD;
  end;
end;

{ Process an element }
procedure TSAXDelphiReader.DoElement(Tag: SAXString; TagType: TXMLTagType;
  Attribs: TStringList);

  { Substitute for entities in the given string }
  function ReplaceEntities(Value: SAXString): SAXString;
  var
    Posn, EndPosn, LastPosn: Integer;
    Name: SAXString;
  begin
    Result   := Value;
    LastPosn := 0;
    repeat
      Posn := Pos('&', Copy(Result, LastPosn + 1, Length(Result)));
      if Posn > 0 then
      begin
        Inc(LastPosn, Posn);
        EndPosn := Pos(';', Copy(Result, LastPosn, Length(Result)));
        if EndPosn = 0 then
          raise ESAXParseException.Create(Format(InvalidEntityRef, [Name]),
            getPublicId, getSystemId, getLineNumber, getColumnNumber);
        Name := Copy(Result, LastPosn + 1, EndPosn - 2);
        Delete(Result, LastPosn, EndPosn);
        Insert(ResolveEntityRef(Name), Result, LastPosn);
      end;
    until Posn = 0;
  end;

  { Start a new element }
  procedure StartElement;
  var
    Index: Integer;
    Attrs: TAttributesImpl;
    AttrName, Prefix, URI: SAXString;
    Parts: TNamespaceParts;
    NSDecl: Boolean;
  begin
    FElements.Add(Tag);
    Attrs := TAttributesImpl.Create;
    FNSSupport.PushContext;
    { Transfer the attributes into a SAX attribute map }
    for Index := 0 to Attribs.Count - 1 do
    begin
      AttrName := Attribs.Names[Index];
      Attribs.Values[AttrName] := ReplaceEntities(Attribs.Values[AttrName]);
      NSDecl := (Copy(AttrName, 1, 5) = XMLNSAttr);
      if NSDecl then
      begin
        { Handle namespace declarations separately }
        Prefix := Copy(AttrName, 7, Length(AttrName));
        URI    := Attribs.Values[AttrName];
        FNSSupport.DeclarePrefix(Prefix, URI);
        getContentHandler.StartPrefixMapping(Prefix, URI);
      end;
    end;
    { Now process the names }
    for Index := 0 to Attribs.Count - 1 do
    begin
      AttrName := Attribs.Names[Index];
      Attribs.Values[AttrName] := ReplaceEntities(Attribs.Values[AttrName]);
      NSDecl := (Copy(AttrName, 1, 5) = XMLNSAttr);
      if UsePrefixes or not NSDecl then
      begin
        { Normal attribute }
        FNSSupport.ProcessName(AttrName, Parts, True);
        Attrs.AddAttribute(Parts[nsURI], Parts[nsLocal], Parts[nsQName],
          'CDATA', Attribs.Values[AttrName]);
      end;
    end;
    FNSSupport.ProcessName(Tag, Parts, False);
    getContentHandler.StartElement(
      Parts[nsURI], Parts[nsLocal], Parts[nsQName], Attrs);

    Attrs.Free;
  end;

  { End an element - verify that it matches the last one opened }
  procedure EndElement;
  var
    Index: Integer;
    Parts: TNamespaceParts;
  begin
    if FElements.Count = 0 then
      Error(Format(MismatchedClosing, [Tag, Absent]))
    else if Tag <> FElements[FElements.Count - 1] then
      Error(Format(MismatchedClosing, [Tag, FElements[FElements.Count - 1]]))
    else
      FElements.Delete(FElements.Count - 1);
    FNSSupport.ProcessName(Tag, Parts, True);
    getContentHandler.EndElement(Parts[nsURI], Parts[nsLocal], Parts[nsQName]);
    { Handle namespaces }
    for Index := 0 to Length(FNSSupport.getDeclaredPrefixes) - 1 do
      getContentHandler.EndPrefixMapping(FNSSupport.getDeclaredPrefixes[Index]);
    FNSSupport.PopContext;
  end;

begin
  case TagType of
    ttOpening:
      StartElement;
    ttClosing:
      EndElement;
    ttEmpty:
      begin
        StartElement;
        EndElement;
      end;
  end;
end;

{ Declare an element }
procedure TSAXDelphiReader.DoElementDecl(Name, Model: SAXString);
var
  Index: Integer;
begin
  if Assigned(FDeclHandler) then
  begin
    { Remove all whitespace }
    for Index := Length(Model) downto 1 do
      if Model[Index] <= ' ' then
        Delete(Model, Index, 1);
    FDeclHandler.ElementDecl(Name, Model);
  end;
end;

{ End a document - verify that all tags were closed }
procedure TSAXDelphiReader.DoEndDocument;
var
  Index: Integer;
  Tags: string;
begin
  if FElements.Count > 0 then
  begin
    Tags := '';
    for Index := FElements.Count - 1 downto 0 do
      Tags := Tags + ', ' + FElements[Index];
    Error(Format(MissingClosing, [Copy(Tags, 3, Length(Tags) - 2)]));
  end;
  getContentHandler.EndDocument;
end;

{ Process an entity declaration }
procedure TSAXDelphiReader.DoEntity(Name: SAXString; Attribs: TStringList);
var
  Stream: TStringStream;
  Source: IInputSource;
  Isis : IStreamInputSource;
begin
  if Attribs.Values[ValueAttr] <> '' then
  begin
    { Internal entity }
    if Assigned(FDeclHandler) and (FDeclarations.IndexOf('~~' + Name) = -1) then
    begin
      { Report first declaration only }
      FDeclarations.Add('~~' + Name);
      FDeclHandler.InternalEntityDecl(Name, Attribs.Values[ValueAttr]);
    end;
    FEntities.Values[Name] := Attribs.Values[ValueAttr];
  end
  else if Attribs.Values[NDataAttr] <> '' then
    { Unparsed external entity }
    getDTDHandler.UnparsedEntityDecl(Name, Attribs.Values[PublicAttr],
      Attribs.Values[SystemAttr], Attribs.Values[NDataAttr])
  else
  begin
    { Parsed external entity }
    if Assigned(FDeclHandler) and (FDeclarations.IndexOf('~~' + Name) = -1) then
    begin
      { Report first declaration only }
      FDeclarations.Add('~~' + Name);
      FDeclHandler.ExternalEntityDecl(Name,
        Attribs.Values[PublicAttr], Attribs.Values[SystemAttr]);
    end;
    Stream := TStringStream.Create('');
    Source := getEntityResolver.ResolveEntity(
        Attribs.Values[PublicAttr], Attribs.Values[SystemAttr]);
    if not Assigned(Source) then
      Source := TStreamInputSource.Create(
        TFileStream.Create(Attribs.Values[SystemAttr], fmOpenRead), soOwned) as IStreamInputSource;
    try
      if (Source.QueryInterface(IStreamInputSource, Isis) = 0) then
      begin
        Stream.CopyFrom(Isis.ByteStream, 0);
      end;
      FEntities.Values[Name] := Stream.DataString;
    finally
      Stream.Free;
      Source:= nil;
    end;
  end;
end;

{ Process an entity reference }
procedure TSAXDelphiReader.DoEntityRef(Name: SAXString);
begin
//  if (Name[1] <> '#') and Assigned(FLexicalHandler) then
  if Assigned(FLexicalHandler) then
    FLexicalHandler.StartEntity(Name);
  DoText(ResolveEntityRef(Name));
//  if (Name[1] <> '#') and Assigned(FLexicalHandler) then
  if Assigned(FLexicalHandler) then
    FLexicalHandler.EndEntity(Name);
end;

{ Process an instruction - don't send XML declaration }
procedure TSAXDelphiReader.DoInstruction(Target, Data: SAXString);
begin
  if LowerCase(Target) <> XMLDecl then
    getContentHandler.ProcessingInstruction(Target, Data);
end;

{ Start a new document }
procedure TSAXDelphiReader.DoStartDocument;
begin
  FElements.Clear;
  with FEntities do
  begin
    Clear;
    { Load standard entities }
    Values['amp']  := '&';
    Values['lt']   := '<';
    Values['gt']   := '>';
    Values['quot'] := '"';
    Values['apos'] := '''';
  end;
  getContentHandler.StartDocument;
end;

{ Process a notation declaration }
procedure TSAXDelphiReader.DoNotation(Name: SAXString; Attribs: TStringList);
begin
  getDTDHandler.NotationDecl(Name, Attribs.Values[PublicAttr],
    Attribs.Values[SystemAttr]);
end;

{ Process text }
procedure TSAXDelphiReader.DoText(Text: SAXString);
begin
  getContentHandler.Characters(Text);
end;

{ Generate an error }
procedure TSAXDelphiReader.Error(Message: string);
begin
  raise ESAXParseException.Create(Message, getPublicId, getSystemId,
    getLineNumber, getColumnNumber);
end;

{ Return the current column position in the source docuemnt }
function TSAXDelphiReader.GetColumnNumber: Integer;
begin
  Result := FParser.Column;
end;

{ Return the current line position in the source docuemnt }
function TSAXDelphiReader.GetLineNumber: Integer;
begin
  Result := FParser.Line;
end;

{ Return the nominated property value }
function TSAXDelphiReader.GetProperty(const Name: SAXString): IProperty;
begin
  if Name = DeclHandlerProperty then
    Result := IKWDeclHandlerProperty(Self)
  else if Name = LexicalHandlerProperty then              
    Result := IKWLexicalHandlerProperty(Self)
  else
    raise ESAXNotRecognizedException.Create(Format(PropertyName, [Name]));
end;

{ Parse the XML document }
procedure TSAXDelphiReader.ParseInput(const Input: IInputSource);
var Stream : TStream;
    Isis : IStreamInputSource;
    Err : TSAXParseError;
    freeStream : Boolean;
begin
  freeStream:= false;
  Stream:= nil;
  FDeclarations.Clear;
  getContentHandler.SetDocumentLocator(Self);
  // Create the parser to a filestream or the input stream
  if (Input.QueryInterface(IStreamInputSource, Isis) = 0) then
  begin
    FParser := TXMLParser.Create(Isis.ByteStream);
  end else
  begin
    Stream:= TFileStream.Create(Input.SystemId, fmOpenRead or fmShareDenyNone);
    FParser := TXMLParser.Create(Stream);
    freeStream:= True;
  end;
  try
    try
      DoStartDocument;
      with FParser do
        while Token <> toEOF do
        begin
          case Token of
            toAttrDecl:    DoAttrDecl(TokenString, Attributes);
            toCData:       DoCData(TokenString);
            toComment:     DoComment(TokenString);
            toDTD:         DoDTD(TokenString, TagType, Attributes);
            toElement:     DoElement(TokenString, TagType, Attributes);
            toElementDecl: DoElementDecl(TokenString, Attributes[0]);
            toEntity:      DoEntity(TokenString, Attributes);
            toEntityRef:   DoEntityRef(TokenString);
            toInstruction: DoInstruction(TokenString, Attributes[0]);
            toNotation:    DoNotation(TokenString, Attributes);
            toText:        DoText(TokenString);
          end;
          NextToken;
        end;
      DoEndDocument;
    except
      on Exc: ESAXParseException do
      begin
        Err:= TSAXParseError.create(PSAXChar(Exc.getMessage()),
          Exc.getPublicId(), Exc.getSystemId(), Exc.getLineNumber(),
          Exc.getColumnNumber());
        getErrorHandler.FatalError(Err as ISAXParseError);
      end;
    end;
  finally
    FParser.Free;
    FParser := nil;
    if (freeStream) then
    begin
      Stream.Free;
    end;
  end;
end;

{ Resolve an entity reference }
function TSAXDelphiReader.ResolveEntityRef(const Name: SAXString): SAXString;
var
  Index: Integer;
begin
  if Name[1] = '#' then
    { Character entity }
    try
      Index  := StrToInt(Copy(Name, 2, Length(Name)));
      Result := Chr(Index);
    except
      raise ESAXParseException.Create(Format(InvalidEntityRef, [Name]),
        getPublicId, getSystemId, getLineNumber, getColumnNumber);
    end
  else
  begin
    { Normal parsed entity }
    Result := FEntities.Values[Name];
    if Result = '' then
      raise ESAXParseException.Create(Format(InvalidEntityRef, [Name]),
        getPublicId, getSystemId, getLineNumber, getColumnNumber);
  end;
end;

function TSAXDelphiReader.DoQueryInterfaceDeclHandler(const IID: TGUID;
  out Obj): HResult; stdcall;

  function Equal(G1, G2 : TGUID) : Boolean;
  begin
    Result:= (G1.D1 = G2.D1) and
             (G1.D2 = G2.D2) and
             (G1.D3 = G2.D3) and
             (G1.D4[0] = G2.D4[0]) and
             (G1.D4[1] = G2.D4[1]) and
             (G1.D4[2] = G2.D4[2]) and
             (G1.D4[3] = G2.D4[3]) and
             (G1.D4[4] = G2.D4[4]) and
             (G1.D4[5] = G2.D4[5]) and
             (G1.D4[6] = G2.D4[6]);
  end;

begin
  if Equal(IID, IInterfaceProperty) then
  begin
    Result:= 0; // S_OK
    IKWDeclHandlerProperty(Obj):= Self;
  end else
    Result:= inherited QueryInterface(IID, Obj);
end;

function TSAXDelphiReader.DoGetDeclHandlerPropertyName: SAXString;
begin
  Result:= DeclHandlerProperty;
end;

function TSAXDelphiReader.DoGetDeclHandlerPropertyValue: IUnknown;
begin
  Result:= FDeclHandler;
end;

procedure TSAXDelphiReader.DoSetDeclHandlerPropertyValue(
  const value: IUnknown);
begin
  FDeclHandler:= IDeclHandler(value);
end;

function TSAXDelphiReader.DoQueryInterfaceLexicalHandler(const IID: TGUID;
  out Obj): HResult; stdcall;

  function Equal(G1, G2 : TGUID) : Boolean;
  begin
    Result:= (G1.D1 = G2.D1) and
             (G1.D2 = G2.D2) and
             (G1.D3 = G2.D3) and
             (G1.D4[0] = G2.D4[0]) and
             (G1.D4[1] = G2.D4[1]) and
             (G1.D4[2] = G2.D4[2]) and
             (G1.D4[3] = G2.D4[3]) and
             (G1.D4[4] = G2.D4[4]) and
             (G1.D4[5] = G2.D4[5]) and
             (G1.D4[6] = G2.D4[6]);
  end;

begin
  if Equal(IID, IInterfaceProperty) then
  begin
    Result:= 0; // S_OK
    IKWLexicalHandlerProperty(Obj):= Self;
  end else
    Result:= inherited QueryInterface(IID, Obj);
end;

function TSAXDelphiReader.DoGetLexicalHandlerPropertyName: SAXString;
begin
  Result:= LexicalHandlerProperty;
end;

function TSAXDelphiReader.DoGetLexicalHandlerPropertyValue: IUnknown;
begin
  Result:= FLexicalHandler;
end;

procedure TSAXDelphiReader.DoSetLexicalHandlerPropertyValue(
  const value: IUnknown);
begin
  FLexicalHandler:= ILexicalHandler(value);
end;

{ TSAXDelphiVendor ------------------------------------------------------------}

function TSAXDelphiVendor.Description: string;
begin
  Result := SAX_VENDOR_KEITHWOOD;
end;

function TSAXDelphiVendor.XMLReader: IXMLReader;
begin
  Result := TSAXDelphiReader.Create;
end;

var
  SAXVendor: TSAXVendor;

function TSAXDelphi.GetVendor: string;
begin
  Result := SAXVendor.Description;
end;

initialization
  SAXVendor        := TSAXDelphiVendor.Create;
  DefaultSAXVendor := SAXVendor.Description;
  RegisterSAXVendor(SAXVendor);

finalization
  UnRegisterSAXVendor(SAXVendor);

end.
